#lang racket


(require "../backends/main.rkt"
         "../base/main.rkt"
         "../ast/main.rkt")
(require (only-in "../constructors/main.rkt"
                  generic-evaluate
                  generic-evaluate-toplevel))
(require "../geometry/main.rkt"
         "../parametrization/main.rkt")

(require (prefix-in mar: "ac-marshal.rkt"))

(provide (rename-out (mar:close close)
                     (mar:layer layer)
                     (mar:open open)
                     (mar:get-view-center get-view-center)
                     (mar:get-view-target get-view-target)
                     (mar:get-view-lens get-view-lens)))

(provide load-autocad-proxy)


; points

(define (point c)
  (mar:add-point c))


; lines

(define (arc angle radius)
  (mar:add-arc u0 radius 0 angle))

(define (elliptical-arc angle x-radius y-radius)
  (error 'elliptical-arc "Not implemented"))

(define (ellipse x-radius y-radius)
  (mar:add-ellipse u0 (xy x-radius 0) (/ x-radius y-radius)))

(define (line closed? coords)
  (define (line-open)
    (if (= (length coords) 2)
        (mar:add-line (first coords) (second coords))
        (mar:add-3d-poly coords)))
  (let ((shape (line-open)))
    (when closed? (mar:set-object-closed shape #t))
    shape))

(define (spline closed? cs type)
  (define (spline-impl begin-tangent end-tangent)
    (if closed?
        (mar:add-spline (append-first cs) begin-tangent end-tangent)
        (mar:add-spline cs begin-tangent end-tangent)))
  
  (match type
    ((auto-spline-type)
     (let-values (((begin-tangent end-tangent) (spline-tangents cs)))
       (spline-impl begin-tangent end-tangent)))
    ((tangent-spline-type begin-tangent end-tangent)
     (spline-impl begin-tangent end-tangent))))


; surfaces

; surface

(define (surface-msg shapes)
  (format "Surface: parameter (shapes) can be 1 closed curve or a list of 2, 3 or 4 coords or lines, given ~A" shapes))

(define (surface-from-closed-line shape)
  (begin0
    (first (mar:add-region (list shape)))
    (delete shape)))

(define (surface-from-coords ps)
  #f)

(define (surface-from-lines lines)
  #f)

; edit: returning first region?
(define (surface-from-shape shape)
  (cond ((mar:line-closed? shape)
         (surface-from-closed-line shape))
        ; edit: hack or correct? perhaps introduce the concept of polysurface
        (else
         (first (mar:add-region (list shape))))))

; edit: returning first region?
(define (surface-from-list shapes)
  (cond
    ((andmap is-coord shapes)
     (mar:add-3d-face shapes))
    ((every mar:line? shapes)
     (first (mar:add-region shapes)))
    (else
     (error 'surface-from-list (surface-msg shapes)))))

(define (surface shapes)
  (cond ((shape? shapes)
         (surface-from-shape shapes))
        ((list? shapes)
         (surface-from-list shapes))
        (else
         (error 'surface (surface-msg shapes)))))

; /surface


; solids

(define (box width length height)
  (mar:add-box u0 width length height))

(define (cone radius height)
  (mar:add-cone (mult-c uz (/ height 2.0)) radius height))

(define (cone-frustrum base-radius top-radius height)
  (mar:add-cone-frustrum u0 base-radius top-radius height))

(define (cylinder radius height)
  (mar:add-cylinder (mult-c uz (/ height 2.0)) radius height))

(define (sphere radius)
  (mar:add-sphere u0 radius))

(define (sweep path shape)
  (mar:sweep shape path))


; generic shapes

(define (circle type radius)
  (match type
    ((line-primitive-type) (mar:add-circle u0 radius))
    ((surface-primitive-type) (surface (circle (line-primitive-type) radius)))))

(define (rectangle type width length)
  (match type
    ((line-primitive-type) (line #t (rectangle-coords width length)))
    ((surface-primitive-type) (surface (rectangle (line-primitive-type) width length)))))


; transformations

(define (extrude length shape)
  (if (mar:line? shape)
      (mar:extrude-surface shape length)
      (mar:add-extruded-solid shape length 0)))

(define intersect mar:intersect)
(define join mar:join)
(define loft mar:loft)

(define (move position shape)
  (mar:move shape u0 position))

(define (offset distance shape)
  (mar:offset shape distance))


; rotate

; edit: fix the angle and zero? test with threshold
(define p-distance-threshold 1e-4)

(define (zero-threshold? p (threshold p-distance-threshold))
  (< (xyz-r p) threshold))

(define (rotate angle normal shape)
  (if (or (< (abs angle) p-distance-threshold) (zero-threshold? normal))
      shape
      (mar:rotate3d shape u0 normal angle)))

; /rotate


(define (scale type size shape/shapes)
  (match type
    ((center-scaling-type)
     (error 'scale "AutoCAD scale: center not implemented"))
    ((origin-scaling-type)
     (if (list? shape/shapes)
         (map
          (λ (shape) (mar:scale shape size))
          shape/shapes)
         (mar:scale shape/shapes size)))))

(define subtract mar:subtract)
(define union mar:union)


; lang

(define (bbox shape)
  (mar:get-bounding-box shape))


; on

; edit: duplicated from rh-backend.rkt
(define (on-shape corner-fn bbox-fn shape1 shape2)
  (let* ((shape1-bb (mar:get-bounding-box shape1))
         (shape2-bb (mar:get-bounding-box shape2))
         (corner (corner-fn shape2-bb))
         (center (bbox-fn shape1-bb corner)))
    (mar:union
     (mar:move shape1 (bbox-center shape1-bb) center)
     shape2)))

(define (on type shapes)
  (match type
    ((x-pos-on-type) (reducer (cλ on-shape bbox-x-pos bbox-center<-left) shapes))
    ((x-neg-on-type) (reducer (cλ on-shape bbox-x-neg bbox-center<-right) shapes))
    ((y-pos-on-type) (reducer (cλ on-shape bbox-y-pos bbox-center<-front) shapes))
    ((y-neg-on-type) (reducer (cλ on-shape bbox-y-neg bbox-center<-back) shapes))
    ((z-pos-on-type) (reducer (cλ on-shape bbox-z-pos bbox-center<-bottom) shapes))
    ((z-neg-on-type) (reducer (cλ on-shape bbox-z-neg bbox-center<-top) shapes))))

; /on


; par

(define (arc-length begin-radians end-radians (counter-clockwise? #t))
  (cond ((< begin-radians end-radians) (- end-radians begin-radians))
        (counter-clockwise? (- (+ end-radians 2pi) begin-radians))
        (else (arc-length end-radians begin-radians))))

; edit: fix arc normal
(define (par-arc shape)
  (let ((center (get-arc-center shape))
        (begin-angle (get-arc-begin-angle shape))
        (end-angle (get-arc-end-angle shape))
        (radius (get-arc-radius shape)))
    (let* ((angle (arc-length begin-angle end-angle))
           (translation (apply m.translate (list-of-coord center)))
           (rotation (m-rotate begin-angle uz)))
      (make-transformation-parametric
       (make-transformation-parametric
        (make-arc-curve angle radius)
        rotation)
       translation))))

(define (par-circle shape)
  (let ((center (get-circle-center shape))
        (normal (get-circle-normal shape))
        (radius (get-circle-radius shape)))
    (let ((translation
           (apply m.translate (list-of-coord center)))
          (rotation
           (m-rotate (angle-c uz normal (cross-c uz normal)) (cross-c uz normal))))
      (make-transformation-parametric
       (make-transformation-parametric
        (make-circle-curve radius)
        rotation)
       translation))))

(define (par shape)
  (finally
   (cond ((arc? shape)
          (par-arc shape))
         ((circle? shape)
          (par-circle shape))
         (else
          (error 'par "Unhandled par shape, implemented only for arcs and circles")))
   (λ () (delete shape))))

; /par


(define (view type projection-type lens shape/shapes)
  (let ((perspective
         (match projection-type
           ((ortho-projection-type) mar:perspective-off)
           ((perspective-projection-type) mar:perspective-on))))
    (match type
      ((auto-view-type direction)
       (mar:auto-view shape/shapes direction perspective lens))
      ((manual-view-type center target)
       (mar:set-view shape/shapes center target perspective lens)))))


; properties


; cad

; info: begin-draw does not do anything in AutoCAD
(define (begin-draw exp) #f)
(define begin-undo-mark mar:begin-undo-mark)

(define (delete-shape shape)
  (mar:delete shape))

(define (delete-shapes)
  (mar:delete-shapes))

; edit: is this correct? what about lists of nodes?
(define (end-draw exp)
  (when (node? exp)
    (mar:redraw mar:ac-active-viewport)))

(define (get-shapes)
  (mar:get-shapes))

(define (render-shape width height path)
  (when (file-exists? path)
    (delete-file path))
  (mar:render width height path))

(define end-undo-mark mar:end-undo-mark)
(define undo mar:undo)


; autocad

(define (arc-ppp p1 p2 p3)
  (mar:add-arc-ppp p1 p2 p3))

(define get-object-name mar:get-object-name)

(define arc? mar:arc?)
(define get-arc-center mar:get-arc-center)
(define get-arc-begin-angle mar:get-arc-begin-angle)
(define get-arc-end-angle mar:get-arc-end-angle)
(define get-arc-radius mar:get-arc-radius)

(define circle? mar:circle?)
(define get-circle-center mar:get-circle-center)
(define get-circle-normal mar:get-circle-normal)
(define get-circle-radius mar:get-circle-radius)

(define delete mar:delete)


; backend

(define-proxy autocad-proxy
  ((evaluate expr) (error 'evaluate "Unreachable code: override in 'load-autocad-proxy'"))
  ((evaluate-toplevel expr) (error 'evaluate-toplevel "Unreachable code: override in 'load-autocad-proxy'"))
  
  
  ; points
  
  ((point c) (point c))
  
  
  ; lines
  
  ((arc angle radius) (arc angle radius))
  ((elliptical-arc angle x-radius y-radius) (elliptical-arc angle x-radius y-radius))
  ((ellipse x-radius y-radius) (ellipse x-radius y-radius))
  ((line closed? coords) (line closed? coords))
  ((nurbs-curve controls knots) (error 'nurbs-curve "Not implemented"))
  ((spline closed? cs type) (spline closed? cs type))
  
  
  ; surfaces
  
  ((donut inner-radius outer-radius) (error 'donut "Not implemented"))
  ((ngon width sides) (error 'ngon "Not implemented"))
  ((nurbs-surface controls u-knots v-knots) (error 'nurbs-surface "Not implemented"))
  ((star width sides stride) (error 'star "Not implemented"))
  ((surface shapes) (surface shapes))
  
  
  ; solids
  
  ((box width length height) (box width length height))
  ((cone radius height) (cone radius height))
  ((cone-frustrum base-radius top-radius height) (cone-frustrum base-radius top-radius height))
  ((cylinder radius height) (cylinder radius height))
  ((pyramid width sides height) (error 'pyramid "Not implemented"))
  ((sphere radius) (sphere radius))
  
  
  ; generic shapes
  
  ((circle type radius) (circle type radius))
  ((rectangle type width length) (rectangle type width length))
  
  
  ; transformations
  
  ((extrude length shape) (extrude length shape))
  ((intersect shape1 shape2) (intersect shape1 shape2))
  ((join shapes) (join shapes))
  ((loft closed? shapes) (loft closed? shapes))
  ((move position shape) (move position shape))
  ((offset distance shape) (offset distance shape))
  ((rotate angle normal shape) (rotate angle normal shape))
  ((scale type c shape/shapes) (scale type c shape/shapes))
  ((subtract shape1 shape2) (subtract shape1 shape2))
  ((sweep path shape) (sweep path shape))
  ((thicken distance shape) (error 'thicken "Not implemented"))
  ((union shape1 shape2) (union shape1 shape2))
  
  
  ; lang
  
  ((align type shape) (error 'align "Not implemented"))
  ((bbox shape) (bbox shape))
  ((on type shapes) (on type shapes))
  ((par shape) (par shape))
  ((view type projection-type lens shape/shapes) (view type projection-type lens shape/shapes))
  
  
  ; properties
  
  ((curve-begin-coord shape) (error 'curve-begin-coord "Not implemented"))
  ((curve-end-coord shape) (error 'curve-end-coord "Not implemented"))
  
  ((surface-curvature shape) (error 'surface-curvature "Not implemented"))
  ((surface-domain shape) (error 'surface-domain "Not implemented"))
  
  
  ; cad
  
  ((begin-draw exp) (begin-draw exp))
  ((begin-undo-mark) (begin-undo-mark))
  ((delete-shape shape) (delete-shape shape))
  ((delete-shapes) (delete-shapes))
  ((end-draw exp) (end-draw exp))
  ((end-undo-mark) (end-undo-mark))
  ((get-shapes) (get-shapes))
  ((render-shape width height path) (render-shape width height path))
  ((undo) (undo)))

(define (load-autocad-proxy)
  (mar:load-autocad-marshall)
  (letrec ((proxy
            (make-autocad-proxy
             #:evaluate (λ (exp) (generic-evaluate proxy exp))
             #:evaluate-toplevel (λ (exp) (generic-evaluate-toplevel proxy exp)))))
    proxy))